Workbench Add-On/Workbench Add-On - Volume 1.iso/BBS-Archive/Dev/ACE_Prgs.lha/lang/lisp.lha/LISP.b

Text File | 1994-12-15 | 9KB | 493 lines

{*
** A LISP interpreter written in ACE BASIC.
**
** Adapted and extended from a Pascal program found in
** "What Computing is All About" by Jan L.E. van de SnepScheut,
** p 203-210.
**
** ACE version by: David J Benn
** Date: 12th-15th December 1994
**
** This minimal dialect of LISP supports the following primitives:
**
** car, cdr, cons, atom, eq, cond, lambda, define, nil, t
**
** This is a pure symbolic-processing subset; no numeric data types
** are supported.
**
** All lists are considered to be quoted.
**
** cond only works in conjunction with defined lambda expressions
** (ie. functions). The same is true for combined applications of
** car and cdr.
**
** Examples of interaction with the interpreter:
** --------------------------------------------
**
** > (car (a b c))
** a
** > (define (atomlist (lambda (x)
**         (cond ((eq x nil) t)
**               ((atom (car x)) (atomlist (cdr x)))
**           (t nil)))))
** (atomlist)
** > (atomlist (a b c d e)
** t
*}

OPTION O-    '..Don't optimise due to a negation optimisation bug in ACE v2.3.

{*
** Constants.
*}
CONST true    = -1&
CONST false    = 0&
CONST default    = -1&
CONST COMPLEMENT= 2&
CONST JAM2    = 1&

CONST alfa    = 9
CONST n     = 1000
CONST maxids    = 100

CONST nil    = -1
CONST t        = -2
CONST atom    = -3
CONST eq    = -4
CONST kar    = -5
CONST kdr    = -6
CONST kons    = -7
CONST lambda    = -8
CONST cond    = -9
CONST define    = -10

{*
** Variables.
*}
STRING ch SIZE 2
LONGINT nrofids
DIM STRING ids(maxids) SIZE alfa
DIM LONGINT a(n)
DIM LONGINT d(n)
DIM LONGINT inuse(n)
LONGINT oldalp, alp, olp, Free
SHORTINT maxcolor
ADDRESS rp
STRING buf

{*
** Library functions.
*}
LIBRARY "graphics.library"
DECLARE FUNCTION SetDrMd(Rp&,MODE) LIBRARY

{*
** Activate event trapping.
*}
ON BREAK GOTO quit
BREAK ON
ON WINDOW GOTO quit
WINDOW ON

{*
** Subprograms.
*}
SUB cursorON
SHARED maxcolor,rp
  SetDrMd(rp,COMPLEMENT)
  COLOR maxcolor
  PRINT "|";
  COLOR 1
  SetDrMd(rp,JAM2)
END SUB

SUB cursorOFF
SHARED maxcolor,rp
  SetDrMd(rp,COMPLEMENT)
  LOCATE CSRLIN,POS-1
  COLOR maxcolor
  PRINT "|"+CHR$(8);
  COLOR 1
  SetDrMd(rp,JAM2)
END SUB

SUB STRING nextch
SHARED buf
STRING k$ SIZE 2
  '..Fill buffer?
  IF LEN(buf) = 0 THEN
    REPEAT
      cursorON
      REPEAT
    SLEEP
          k$ = INKEY$
      UNTIL k$ <> ""
      cursorOFF
      '..CR?
      IF ASC(k$) = 13 THEN k$ = CHR$(10)
      '..Destructive backspace?
      IF k$ = CHR$(8) THEN
        IF LEN(buf) > 0 THEN
      buf = LEFT$(buf,LEN(buf)-1)
      PRINT CHR$(8);
    END IF
      ELSE
    '..Tab?
        IF ASC(k$) = 9 THEN
          buf = buf + SPACE$(10)
      PRINT SPACE$(10);
        ELSE
      '..Other character.
          buf = buf + k$
          PRINT k$;
        END IF
      END IF
    UNTIL ASC(k$) = 10
  END IF
  '..Return left-most character in buffer.
  nextch = LEFT$(buf,1)
  buf = RIGHT$(buf,LEN(buf)-1)
END SUB

SUB erm(LONGINT num)
SHARED alp, oldalp, ch
  PRINT
  PRINT "*** error : ";
  CASE
    num=1  : PRINT "illegal application : no function name"
    num=2  : PRINT "car of an atom"
    num=3  : PRINT "cdr of an atom"
    num=4  : PRINT "garbage collector finds no free space"
    num=5  : PRINT "symbol ) expected"
    num=6  : PRINT "incorrect starting symbol of expression [ASCII";STR$(ASC(ch));"]"
    num=7  : PRINT "too many identifiers"
    num=8  : PRINT "undefined identifier"
    num=9  : PRINT "too few actual parameters"
    num=10 : PRINT "too many actual parameters"
  END CASE
  alp = oldalp
  ch = " "
  GOTO 13
END SUB

SUB LONGINT letter(STRING c)
  IF c >= "A" AND c <= "Z" THEN
    letter = true
  ELSE
    IF c >= "a" AND c <= "z" THEN
      letter = true
    ELSE
      IF c >= "0" AND c <= "9" THEN
    letter = true
      ELSE
    letter = false
      END IF
    END IF
  END IF
END SUB

SUB LONGINT identifier
SHARED ch, nrofids, ids
LONGINT i, j
STRING id SIZE alfa
  j=0
  WHILE letter(ch)
    IF j <> alfa-1 THEN
      ++j
      id = id + ch
    END IF
    ch = nextch
  WEND
  IF nrofids = maxids THEN CALL erm(7)
  ids(nrofids+1) = id
  i=1
  WHILE ids(i) <> id
    ++i
  WEND
  IF i > nrofids THEN nrofids = i
  identifier =  -i
END SUB

SUB printatom(LONGINT x)
SHARED ids
  PRINT ids(-x);
END SUB

SUB skipspaces
SHARED ch
  WHILE ASC(ch) = 32 OR ASC(ch) = 9 OR ASC(ch) = 10 OR ch = ";"
    IF ch = ";" THEN
      WHILE ASC(ch) <> 10
    ch = nextch
      WEND
    END IF
    ch = nextch
  WEND
END SUB

SUB LONGINT islist(LONGINT x)
SHARED d
  WHILE x > 0
    x = d(x)
  WEND
  islist = (x = nil)
END SUB

SUB printit(LONGINT x)
SHARED a, d
  IF x < 0 THEN
    printatom(x)
  ELSE
    PRINT "(";
    IF islist(x) THEN
      printit(a(x)) : x = d(x)
      WHILE x > 0
        PRINT " ";
       printit(a(x)) : x = d(x)
      WEND
    ELSE
      printit(a(x)) : PRINT " . "; : printit(d(x))
    END IF
    PRINT ")";
  END IF
END SUB

SUB mark(LONGINT ref)
SHARED inuse, a, d
  IF ref <= 0 THEN EXIT SUB
  WHILE ref > 0 AND NOT inuse(ref)  '..if ref < 0 -> illegal array subscript!!
    inuse(ref) = true
    mark(a(ref))
    ref = d(ref)
  WEND
END SUB

SUB collectgarbage
SHARED inuse, olp, alp, d, Free
LONGINT i
  PRINT "Collecting garbage... ";
  FOR i=1 TO n : inuse(i) = false : NEXT
  mark(olp) : mark(alp)
  FOR i=1 TO n
    IF NOT inuse(i) THEN
      d(i) = Free
      Free = i
    END IF
  NEXT
  PRINT "done."
  IF Free = nil THEN CALL erm(4)
END SUB

SUB LONGINT cons(LONGINT x, LONGINT y)
SHARED Free, d, a
LONGINT ref
  IF Free = nil THEN CALL collectgarbage
  ref = Free : cons = ref : Free = d(ref)
  a(ref) = x : d(ref) = y
END SUB

SUB LONGINT car(LONGINT x)
SHARED a
  IF x < 0 THEN CALL erm(2)
  car = a(x)
END SUB

SUB LONGINT cdr(LONGINT x)
SHARED d
  IF x < 0 THEN CALL erm(3)
  cdr = d(x)
END SUB

SUB LONGINT readitem
SHARED ch, olp, a, d
LONGINT x, tmp, theItem
  skipspaces
  IF letter(ch) THEN
    readitem = identifier
  ELSE
    IF ch <> "(" THEN CALL erm(6)
    ch = nextch
    skipspaces
    IF ch = ")" THEN
      ch = nextch : readitem = nil
    ELSE
      olp = cons(nil,olp) : x = cons(nil,nil) : a(olp) = x
      theItem = x
      tmp = readitem : a(x) = tmp : skipspaces
      IF ch = "." THEN
           ch = nextch : tmp = readitem : d(x) = tmp
    skipspaces : IF ch <> ")" THEN CALL erm(5)
      ELSE
    WHILE ch <> ")"
      tmp = cons(nil,nil) : d(x) = tmp : x = d(x)
      tmp = readitem : a(x) = tmp : skipspaces
    WEND
      END IF
      ch = nextch : olp = d(olp)
    END IF
    readitem = theItem
  END IF
END SUB

DECLARE SUB LONGINT eval(LONGINT e)

SUB LONGINT evcon(LONGINT x)
SHARED d, a
  WHILE eval(car(car(x))) = nil
    x = d(x)
  WEND
  evcon = eval(car(d(a(x))))
END SUB

SUB LONGINT evlis(LONGINT x)
SHARED olp, a, d
LONGINT op, retVal, tmp
  IF x = nil THEN
    evlis = nil
  ELSE
    op = olp : olp = cons(nil,olp)
    retVal = olp
    tmp = eval(car(x)) : a(olp) = tmp
    tmp = evlis(d(x)) : d(olp) = tmp
    olp = op
    evlis = retVal
  END IF
END SUB

SUB LONGINT assoc(LONGINT x)
SHARED alp, a, d
LONGINT al
  al = alp
  WHILE al <> nil AND a(a(al)) <> x
    al = d(al)
  WEND
  IF al = nil THEN CALL erm(8)
  assoc = d(a(al))
END SUB

SUB pairlis(LONGINT x, LONGINT y)
SHARED alp, a
LONGINT tmp
  IF x <> nil THEN
    IF y = nil THEN CALL erm(9)
    pairlis(cdr(x), cdr(y))
    alp = cons(nil,alp) : tmp = cons(a(x),a(y)) : a(alp) = tmp
  ELSE
    IF y <> nil THEN CALL erm(10)
  END IF
END SUB

SUB LONGINT logical(LONGINT b)
  IF b THEN logical = t ELSE logical = nil
END SUB

SUB LONGINT apply(LONGINT func, LONGINT x)
SHARED a, alp, d
LONGINT ap
  IF func < 0 THEN
    CASE
      func = kar  : apply = car(car(x))
      func = kdr  : apply = cdr(car(x))
      func = kons : apply = cons(car(x),car(cdr(x)))
      func = atom : apply = logical(car(x) < 0)
      func = eq   : apply = logical(car(x) = car(cdr(x)))
      default     : apply = apply(assoc(func),x)
    END CASE
  ELSE
    IF a(func) = lambda THEN
      ap = alp : pairlis(car(d(func)),x)
      apply = eval(car(d(d(func)))) : alp = ap
    ELSE
      erm(1)
    END IF
  END IF
END SUB

SUB LONGINT eval(LONGINT e)
SHARED a, d, olp
LONGINT tmp
  IF e < 0 THEN
    IF e = nil OR e = t THEN eval = e ELSE eval = assoc(e)
  ELSE
    IF a(e) = quote THEN
      eval = car(d(e))
    ELSE
      IF a(e) = cond THEN
        eval = evcon(d(e))
      ELSE
    olp = cons(nil,olp) : tmp = evlis(d(e)) : a(olp) = tmp
       eval = apply(a(e),a(olp)) : olp = d(olp)
      END IF
    END IF
  END IF
END SUB

SUB interpret
SHARED olp, ch, a, d, alp
LONGINT e, p, tmp
  PRINT "> ";
  skipspaces
  olp = nil : olp = cons(nil,nil)
  e = readitem : a(olp) = e
  IF car(e) = define THEN
    e = d(e) : PRINT "(";
    REPEAT
      p = car(e) : printit(car(p)) : alp = cons(nil,alp)
      tmp = cons(a(p),car(d(p))) : a(alp) = tmp : e = cdr(e)
      IF e <> nil THEN PRINT " ";
    UNTIL e = nil
    PRINT ")"
  ELSE
    printit(apply(a(e),d(e))) : PRINT
  END IF
END SUB

{*
** Main.
*}
WINDOW 1,"LISP Interpreter - version 1.0",(0,0)-(640,200)
rp = WINDOW(8)
maxcolor = WINDOW(6)

PRINT "Setting up..."

FOR i% = 1 TO n-1
  d(i%) = i%+1
NEXT

d(n) = nil
Free = 1

ids(-nil)     = "nil"
ids(-t)     = "t"
ids(-atom)     = "atom"
ids(-eq)    = "eq"
ids(-kar)    = "car"
ids(-kdr)    = "cdr"
ids(-kons)    = "cons"
ids(-lambda)    = "lambda"
ids(-cond)    = "cond"
ids(-define)    = "define"

nrofids = 10
alp = nil
ch = " "

CLS

13 REPEAT
     oldalp = alp
     interpret
   UNTIL false

{*
** Event handler.
*}
quit:
  cursorOFF
  PRINT
  PRINT "*** Break: LISP terminating."
  SLEEP FOR .75
  WINDOW CLOSE 1
STOP